home *** CD-ROM | disk | FTP | other *** search
/ Mac Magazin/MacEasy 25 / Mac Magazin and MacEasy Magazine CD - Issue 25.iso / Grafik & Text / Alpha / Tcl / SystemCode / misc.tcl < prev    next >
Text File  |  1996-08-18  |  27KB  |  1,020 lines
  1. #===========================================================================
  2. # Information about a selection or window.
  3. #===========================================================================
  4. proc wordCount {} {
  5.     if {[set chars [expr {[selEnd] - [getPos]}]]} {
  6.         set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
  7.         set text [getSelect]
  8.     } else {
  9.         set chars [maxPos]
  10.         set lines [lindex [posToRowCol $chars] 0]
  11.         set text [getText 0 [maxPos]]
  12.     }
  13.     if {[regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " ret]} {
  14.         set words [llength $ret]
  15.     } else {
  16.         set words [llength $text]
  17.     }
  18.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  19. }
  20.  
  21. #=============================================================================
  22. # Random functions.
  23. #=============================================================================
  24.  
  25. #================================================================================
  26.  
  27. proc nextFunc {} {
  28.     searchFunc 1
  29. }
  30.  
  31. proc prevFunc {} {
  32.     searchFunc 0
  33. }
  34.  
  35. proc searchFunc {dir} {
  36.     global funcExpr
  37.     set pos [getPos]
  38.     select $pos
  39.     if ($dir==1) {
  40.         incr pos
  41.     } else {
  42.         set pos [expr $pos-1]
  43.     }
  44.     if {![catch {search -s -f $dir -i 1 -r 1 $funcExpr $pos} res]} {
  45.         eval select $res
  46.     }
  47. }
  48.  
  49. #===========================================================================
  50. # Comment routines.
  51. #===========================================================================
  52. proc commentPara {} {
  53. }
  54.  
  55.  
  56.  
  57. #===========================================================================
  58. # Sorting the selection.
  59. # AUTHOR: David C. Black     black@mpd.tandem.com
  60. #===========================================================================
  61. proc sortLines {} {
  62.     set ends [getEndpts]
  63.     set start [lindex $ends 0]
  64.     set end  [lindex $ends 1]
  65.     if {$start == $end} {
  66.         alertnote "You must highlight the section you wish to sort."
  67.         return
  68.     }
  69.     if {[lookAt [expr $end-1]] != "\r"} {
  70.         alertnote "The selection must consist only of complete lines."
  71.         return
  72.     }
  73.     set text [getText $start [expr {$end-1}]]
  74.     set text [join [lsort [split $text "\r"]] "\r"]
  75.     replaceText $start [expr {$end-1}] $text
  76.     select $start $end
  77. }
  78.  
  79.  
  80.  
  81. #===========================================================================
  82. # Dump all current settings into a file.
  83. #===========================================================================
  84. proc insertGlobalSettings {} {
  85.     uplevel #0 {
  86.         foreach var [info globals] {
  87.             if {![catch {set $var}]} {
  88.                 insertText "set " $var " \{" [set $var] "\}\r"
  89.             }
  90.         }
  91.     }
  92. }
  93.  
  94.  
  95. #================================================================================
  96. # Substitute global variables in possibly nested list.
  97. #================================================================================
  98. proc subVars {words} {
  99.     global silly
  100.     global a
  101.     set silly $words
  102.     set out {}
  103.     foreach a $words {
  104.         if {[llength $a] == 1} {
  105.             lappend out [uplevel #0 {eval set x $a}]
  106.         } else {
  107.             lappend out [subVars $a]
  108.         }
  109.     }
  110.     return $out
  111. }
  112.  
  113. #================================================================================
  114. # Block shift left and right.
  115. #================================================================================
  116.  
  117. proc shiftLeft {} {
  118.     global shiftChar
  119.     doShiftLeft "\t"
  120.     
  121. }
  122. proc shiftLeftSpace {} {
  123.     global shiftChar
  124.     doShiftLeft " "
  125. }
  126.  
  127. proc doShiftLeft {shiftChar} {
  128.      set start [lineStart [getPos]]
  129.      set end [nextLineStart [expr [selEnd] - 1]]
  130.     if {$start >= $end} {set end [nextLineStart $start]}
  131.     
  132.     set text [split [getText $start [expr $end - 1]] "\r"]
  133.     
  134.     set textout ""
  135.     
  136.     foreach line $text {
  137.         if {[string index $line 0] == $shiftChar} {
  138.             lappend textout [string range $line 1 end]
  139.         } else {
  140.             lappend textout $line
  141.         }
  142.     }
  143.  
  144.     set text [join $textout "\r"]    
  145.     replaceText $start [expr $end - 1] $text
  146.     select $start [expr 1 + $start + [string length $text]]
  147. }
  148.  
  149.  
  150. proc shiftRight {} {
  151.     global shiftChar
  152.     doShiftRight "\t"
  153.     
  154. }
  155. proc shiftRightSpace {} {
  156.     global shiftChar
  157.     doShiftRight " "
  158. }
  159. proc doShiftRight {shiftChar} {
  160.     set start [lineStart [getPos]]
  161.     set end [nextLineStart [expr [selEnd] - 1]]
  162.     if {$start >= $end} {set end [nextLineStart $start]}
  163.     
  164.     set text [split [getText $start [expr $end - 1]] "\r"]
  165.     
  166.     set textout ""
  167.     
  168.     foreach line $text {
  169.         lappend textout $shiftChar$line
  170.     }
  171.     
  172.     set text [join $textout "\r"]    
  173.     replaceText $start [expr $end - 1] $text
  174.     select $start [expr 1 + $start + [string length $text]]
  175. }
  176.  
  177.  
  178.  
  179. # rglobText [option list] dir pat
  180. # 'dir' should be a properly formed directory, ending w/ a ':'. 'pat' should be 
  181. # a simple pattern w/ no directory specifications (i.e. "*.c").
  182. proc rglobText {optlist dir pat} {
  183.  
  184.     message "$dir"
  185.     set cmd [concat glob -t TEXT $optlist]
  186.     lappend cmd $dir$pat
  187.     if {[catch {eval $cmd} files]} {
  188.         set files ""
  189.     }
  190.     
  191.     if {![catch {glob $dir*} all]} {
  192.         foreach f $all {
  193.             if {[file isdir $f]} {
  194.                 set files [concat $files [rglobText $optlist $f: $pat]]
  195.             }
  196.         }
  197.     }
  198.     return $files
  199. }
  200.  
  201.  
  202. proc switchApp {} {
  203.     set procs ""
  204.     foreach p [processes] {
  205.         lappend procs [lindex $p 0]
  206.     }
  207.     set to [listpick -p "Switch to app:" [lsort $procs]]
  208.     if {[string length $to]} {
  209.         switchTo $to
  210.     }
  211. }
  212.  
  213.  
  214. proc selectAll {} {
  215.     select 0 [maxPos]
  216. }
  217.  
  218.  
  219. proc twiddle {} {
  220.     set pos [getPos]
  221.     if {!$pos || ($pos == [maxPos])} return;
  222.     if {[string length [set text [getSelect]]]} {
  223.         if {[string length $text] == 1} {
  224.             return
  225.         } else {
  226.             set sel [expr [selEnd] - 1]
  227.             set one [lookAt $sel]
  228.             set two [lookAt $pos]
  229.             replaceText $pos [expr $sel + 1] "$one[getText [expr $pos+1] $sel]$two"
  230.             select $pos [expr $sel+1]
  231.             return
  232.         }
  233.     }
  234.     set one [lookAt $pos]
  235.     set two [lookAt [expr $pos-1]]
  236.     replaceText [expr $pos-1] [expr $pos + 1] "$one$two"
  237.     select  [expr $pos-1] [expr $pos + 1]
  238. }
  239.  
  240. proc twiddleWords {} {
  241.     global wordBreakPreface wordBreak
  242.  
  243.     if {[getPos] != [selEnd]} {
  244.         set start1 [getPos]; set end2 [selEnd]
  245.         select $start1
  246.         forwardWord; set end1 [getPos]
  247.         goto $end2
  248.         backwardWord; set start2 [getPos]
  249.     } else {
  250.         select [set pos [getPos]]
  251.         backwardWord; set start1 [getPos]
  252.         forwardWord; set end1 [getPos]
  253.         goto $pos
  254.         forwardWord; set end2 [getPos]
  255.         backwardWord; set start2 [getPos]
  256.     }        
  257.  
  258.     if {$start1 != $start2} {
  259.         set mid [getText $end1 $start2]
  260.         replaceText $start1 $end2 "[getText $start2 $end2]$mid[getText $start1 $end1]"
  261.         select $start1 $end2
  262.     }
  263. }
  264.  
  265. #================================================================================
  266. # Print a window using John Cho's Enscriptor (A text file printing app that
  267. # works like Adobe Enscript.)
  268. #
  269.  
  270. proc setupPrintMenu {} {
  271.     global pathComments defaultPrinter modifiedVars
  272.     if {![info exists defaultPrinter]} {
  273.         set defaultPrinter "Alpha"
  274.         lappend modifiedVars defaultPrinter
  275.     }
  276.     set m [list {/P<SPrint…} {/P<S<I<OPrint All…} {(-} Alpha Kodex Enscriptor {Drop•PS} PrettyC]
  277.     menu -m -n print -p printProc $m
  278.     
  279.     foreach item $m {
  280.         if {$item == $defaultPrinter} {
  281.             markMenuItem -m print $item on
  282.         } else {
  283.             markMenuItem -m print $item off
  284.         }
  285.     }
  286. }
  287.  
  288. proc printProc {menu item} {
  289.     global modifiedVars defaultPrinter pathComments
  290.     switch -glob $item {
  291.         "Print All"        {    if {$defaultPrinter == "Alpha"} {
  292.                                 printAll
  293.                             } else {
  294.                                 foreach f [winNames -f] {
  295.                                     printFile $f
  296.                                 }
  297.                             }
  298.                         }
  299.         "Print"            {printFile [car [winNames -f]]}
  300.         default            {set defaultPrinter $item; lappend modifiedVars defaultPrinter; setupPrintMenu}
  301.     }
  302. }
  303.  
  304.  
  305. proc printFile {fname} {
  306.     global defaultPrinter
  307.     
  308.     switch -glob $defaultPrinter {
  309.         "Alpha"            {print}
  310.         "Kodex*"        {openAndSendFile KoDX}
  311.         "Enscr*"        {openAndSendFile Ens3}
  312.         "Drop*"            {openAndSendFile {D•PS}}
  313.         "Pret*"            {openAndSendFile niCe}
  314.     }
  315. }
  316.  
  317.  
  318. proc commentBox {} {
  319.  
  320. # Preliminaries
  321.     if [commentGetRegion Box] { return }
  322.     
  323.     set commentList [commentCharacters Box]
  324.     if { [llength $commentList] == 0 } { return }
  325.     
  326.     set begComment [lindex $commentList 0]
  327.     set begComLen [lindex $commentList 1]
  328.     set endComment [lindex $commentList 2]
  329.     set endComLen [lindex $commentList 3]
  330.     set fillChar [lindex $commentList 4]
  331.     set spaceOffset [lindex $commentList 5]
  332.  
  333.     set aSpace " "
  334.  
  335. # First make sure we grab a full block of lines and adjust highlight
  336.  
  337.     set start [getPos]
  338.     set start [lineStart $start]
  339.     set end [selEnd]
  340.     set end [nextLineStart [expr $end-1]]
  341.     select $start $end
  342.  
  343. # Now get rid of any tabs
  344.     
  345.     if { $end < [maxPos] } then {
  346.         createTMark stopComment [expr $end+1]
  347.         tabsToSpaces
  348.         gotoTMark stopComment
  349.         set end [expr [getPos]-1]
  350.         removeTMark stopComment
  351.     } else {
  352.         tabsToSpaces
  353.         set end [maxPos]
  354.     }
  355.     select $start $end
  356.     set text [getText $start $end]
  357.     
  358. # Next turn it into a list of lines--possibly drop an empty 'last line'
  359.  
  360. # VMD May'95: changed this code segment because it
  361. # previously had problems with empty lines in the
  362. # middle of the text to be commented
  363.  
  364.     set lineList [split $text "\r"]
  365.     set ll [llength $lineList]
  366.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  367.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  368.     }
  369.     set numLines [llength $lineList]
  370.  
  371. # end changes.
  372.     
  373. # Find the longest line length and determine the new line length
  374.  
  375.     set maxLength 0
  376.     foreach thisLine $lineList {
  377.         set thisLength [string length $thisLine]
  378.         if { $thisLength > $maxLength } then { 
  379.             set maxLength $thisLength 
  380.         }
  381.     }
  382.     set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]
  383.     
  384. # Now create the top & bottom bars and a blank line
  385.  
  386.     set topBar $begComment
  387.     for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
  388.         set topBar $topBar$fillChar
  389.     }
  390.     set botBar ""
  391.     for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
  392.         set botBar $botBar$fillChar
  393.     }
  394.     set botBar $botBar$endComment
  395.     set blankLine $fillChar
  396.     for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
  397.         set blankLine $blankLine$aSpace
  398.     }
  399.     set blankLine $blankLine$fillChar
  400.     
  401. # For each line add stuff on left and spaces and stuff on right for box sides
  402. # and concatenate everything into 'text'.  Start with topBar; end with botBar
  403.  
  404.     set text $topBar\r$blankLine\r
  405.     
  406.     set frontStuff $fillChar
  407.     set backStuff $fillChar
  408.     for { set i 0 } { $i < $spaceOffset } { incr i } {
  409.         set frontStuff $frontStuff$aSpace  
  410.         set backStuff $aSpace$backStuff
  411.     }
  412.     set backStuffLen [string length $backStuff]
  413.     
  414.     for { set i 0 } { $i < $numLines } { incr i } {
  415.         set thisLine [lindex $lineList $i ]
  416.         set thisLine $frontStuff$thisLine
  417.         set thisLength [string length $thisLine]
  418.         set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
  419.         for { set j 0 } { $j < $howMuchPad } { incr j } {
  420.             set thisLine $thisLine$aSpace 
  421.         }
  422.         set thisLine $thisLine$backStuff
  423.         set text $text$thisLine\r
  424.     }
  425.     
  426.     set text $text$blankLine\r$botBar\r
  427.     
  428. # Now replace the old stuff, turn spaces to tabs, and highlight
  429.  
  430.     replaceText    $start $end    $text
  431.     set    end    [expr {$start+[string length $text]}]
  432.     cleverSpacesToTabs $start $end
  433. }
  434.  
  435. proc uncommentBox {} {
  436.  
  437. # Preliminaries
  438.     if [commentGetRegion Box 1] { return }
  439.     
  440.     set commentList [commentCharacters Box]
  441.     if { [llength $commentList] == 0 } { return }
  442.     
  443.     set    begComment [lindex $commentList    0]
  444.     set    begComLen [lindex $commentList 1]
  445.     set    endComment [lindex $commentList    2]
  446.     set    endComLen [lindex $commentList 3]
  447.     set    fillChar [lindex $commentList 4]
  448.     set    spaceOffset    [lindex    $commentList 5]
  449.  
  450.     set aSpace " "
  451.     set aTab \t
  452.  
  453. # First make sure we grab a full block of lines
  454.  
  455.     set start [getPos]
  456.     set start [lineStart $start]
  457.     set end [selEnd]
  458.     set end [nextLineStart [expr $end-1]]
  459.     set text [getText $start $end]
  460.  
  461. # Make sure we're at the start and end of the box
  462.  
  463.     set startOK [string first $begComment $text]
  464.     set endOK [string last $endComment $text]
  465.     set textLength [string length $text]
  466.     if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } then {
  467.         alertnote "You must highlight the entire comment box, including the borders."
  468.         return
  469.     }
  470.     
  471. # Now get rid of any tabs
  472.     
  473.     if { $end < [maxPos] } then {
  474.         createTMark stopComment [expr $end+1]
  475.         tabsToSpaces
  476.         gotoTMark stopComment
  477.         set end [expr [getPos]-1]
  478.         removeTMark stopComment
  479.     } else {
  480.         tabsToSpaces
  481.         set end [maxPos]
  482.     }
  483.     select $start $end
  484.     set text [getText $start $end]
  485.     
  486. # Next turn it into a list of lines--possibly drop an empty 'last line'
  487.  
  488. # VMD May'95: changed this code segment because it
  489. # previously had problems with empty lines in the
  490. # middle of the text to be commented
  491.  
  492.     set lineList [split $text "\r"]
  493.     set ll [llength $lineList]
  494.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  495.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  496.     }
  497.     set numLines [llength $lineList]
  498.  
  499. # end changes.
  500.     
  501. # Delete the first and last lines, recompute number of lines
  502.  
  503.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  504.     set lineList [lreplace $lineList 0 0 ]
  505.     set numLines [llength $lineList]
  506.     
  507. # Eliminate 2nd and 2nd-to-last lines if they are empty
  508.  
  509.     set eliminate $fillChar$aSpace$aTab
  510.     set thisLine [lindex $lineList [expr $numLines-1]]
  511.     set thisLine [string trim $thisLine $eliminate]
  512.     if { [string length $thisLine] == 0 } then {
  513.         set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  514.     }
  515.     set thisLine [lindex $lineList 0]
  516.     set thisLine [string trim $thisLine $eliminate]
  517.     if { [string length $thisLine] == 0 } then {
  518.         set lineList [lreplace $lineList 0 0 ]
  519.     }
  520.     set numLines [llength $lineList]    
  521.     
  522. # For each line trim stuff on left and spaces and stuff on right and splice
  523.  
  524.     set dropFromLeft [expr $spaceOffset+1]
  525.     set text ""
  526.     for { set i 0 } { $i < $numLines } { incr i } {
  527.         set thisLine [lindex $lineList $i]
  528.         set thisLine [string trimright $thisLine $eliminate]
  529.         set thisLine [string range $thisLine $dropFromLeft end]
  530.         set text $text$thisLine\r
  531.     }
  532.         
  533. # Now replace the old stuff, convert spaces back to tabs
  534.  
  535.     replaceText    $start $end    $text
  536.     set end [expr {$start+[string    length $text]}]
  537.     cleverSpacesToTabs $start $end
  538. }
  539.  
  540. proc commentCharacters { purpose } {
  541.     global mode
  542.     
  543.     switch $purpose {
  544.         "Paragraph" {        
  545.             switch $mode {
  546.                 "TeX" {return [list "%% " " %%" " % "] }
  547.                 "Text" {return [list "!! " " !!" " ! "] }
  548.                 "Fort" {return [list "CC " " CC" " C "] }
  549.                 "Tcl" {return [list "## " " ##" " # "] }
  550.                 "C" {return [list "/* " " */" " * "] }
  551.                 "C++" {return [list "/* " " */" " * "] }
  552.                 default {
  553.                     alertnote "I don't know what comments should look like in this mode.  Sorry."
  554.                     return
  555.                 }
  556.             }
  557.         }
  558.         "Box" {
  559.         switch $mode {
  560.                 "TeX" {return [list "%" 1 "%" 1 "%" 3] }
  561.                 "Text" {return [list "!" 1 "!" 1 "!" 3] }
  562.                 "Fort" {return [list "C" 1 "C" 1 "C" 3] }
  563.                 "Tcl" {return [list "#" 1 "#" 1 "#" 3] }
  564.                 "C" {return [list "/*" 2 "*/" 2 "*" 3] }
  565.                 "C++" {return [list "/*" 2 "*/" 2 "*" 3] }
  566.                 default {
  567.                     alertnote "I don't know what comments should look like in this mode.  Sorry."
  568.                     return
  569.                 }
  570.             }    
  571.         }
  572.     }    
  573.  
  574. }
  575.  
  576. ## 
  577.  # Default is to look for a    paragraph to comment out.
  578.  # If sent '1',    then we    look for a commented region    to 
  579.  # uncomment.
  580.  ##
  581. proc commentGetRegion { purpose {uncomment 0 } } {
  582.     if {[getPos] != [selEnd]} {
  583.         watchCursor
  584.         return 0    
  585.     }
  586.  
  587.     # there's no selection, so we try and generate one
  588.     
  589.     set pos [getPos]
  590.     if $uncomment {
  591.         # uncommenting
  592.         set commentList [commentCharacters $purpose]
  593.         if { [llength $commentList] == 0 } { return 1}
  594.         switch $purpose {
  595.             "Box" {
  596.                 set begComment [lindex $commentList 0]
  597.                 set begComLen [lindex $commentList 1]
  598.                 set endComment [lindex $commentList 2]
  599.                 set endComLen [lindex $commentList 3]
  600.                 set fillChar [lindex $commentList 4]
  601.                 set spaceOffset [lindex $commentList 5]
  602.                 
  603.                 # get length of current line
  604.                 set line [getText [lineStart $pos] [nextLineStart $pos] ]
  605.                 set c [string trimleft $line]
  606.                 set slen [expr [string length $line] - [string length $c] ]
  607.                 set start [string range $line 0 [expr $slen -1 ] ]
  608.                 
  609.                 set pos [getPos]
  610.                 
  611.                 if { $start == "" } {
  612.                     set p $pos
  613.                     while { [string first $fillChar $line] == 0 && \
  614.                         [expr [string last $fillChar $line] + [string length $fillChar]] \
  615.                         >= [string length [string trimright $line]] } {
  616.                         set p [nextLineStart $p]
  617.                         set line [getText [lineStart $p] [nextLineStart $p]]
  618.                     }
  619.                     set end [lineStart $p]
  620.                     
  621.                     set p $pos
  622.                     set line "${fillChar}"
  623.                     while { [string first $fillChar $line] == 0 && \
  624.                         [expr [string last $fillChar $line] + [string length $fillChar]] \
  625.                         >= [string length [string trimright $line]] } {
  626.                         set p [prevLineStart $p]
  627.                         set line [getText [prevLineStart $p] [lineStart $p] ]
  628.                     }
  629.                     set begin [prevLineStart $p]
  630.                     
  631.                 } else {
  632.                     set line "$start"
  633.                     set p $pos
  634.                     while { [string range $line 0 [expr $slen -1] ] == "$start" } {
  635.                         set p [nextLineStart $p]
  636.                         set line [getText [lineStart $p] [nextLineStart $p]]
  637.                     }
  638.                     set end [prevLineStart $p]
  639.                     
  640.                     set p $pos
  641.                     set line "$start"
  642.                     while { [string range $line 0 [expr $slen -1] ] == "$start" } {
  643.                         set p [prevLineStart $p]
  644.                         set line [getText [prevLineStart $p] [lineStart $p] ]
  645.                     }
  646.                     set begin [lineStart $p]
  647.                 }
  648.  
  649.                 set beginline [getText $begin [nextLineStart  $begin]]
  650.                 if { [string first "$begComment" "$beginline" ] != $slen } {
  651.                     message "First line failed"
  652.                     return 1
  653.                 }
  654.                 
  655.                 set endline [getText $end [nextLineStart $end]]
  656.                 set epos [string last "$endComment" "$endline"]
  657.                 incr epos [string length $endComment]
  658.                 set s [string range $endline $epos end ]
  659.                 set s [string trimright $s]
  660.                 
  661.                 if { $s != "" } {
  662.                     message "Last line failed"
  663.                     return 1
  664.                 }
  665.                 
  666.                 set end [nextLineStart $end]
  667.                 select $begin $end
  668.                 #alertnote "Sorry auto-box selection not yet implemented"
  669.             }
  670.             "Paragraph" {
  671.                 set begComment [lindex $commentList 0]
  672.                 set endComment [lindex $commentList 1]
  673.                 set fillChar [lindex $commentList 2]
  674.                 
  675.                 ## 
  676.                  # basic idea is search    back and forwards for lines
  677.                  # that    don't begin    the    same way and then see if they
  678.                  # match the idea of the beginning and end of a    block
  679.                  ##
  680.                 
  681.                 set line [getText [lineStart $pos] [nextLineStart $pos] ]
  682.                 set chk [string range $line 0 [string first $fillChar $line]]
  683.                 if { [string trimleft $chk] != "" } {
  684.                     message "Not in a comment block"
  685.                     return 1
  686.                 }
  687.                 regsub -all {    } $line " " line
  688.                 set p [string first "$fillChar" "$line"]
  689.                 set start [string range "$line" 0 [expr $p + [string length $fillChar] -1 ]]
  690.                 set ll [commentGetFillLines $start]
  691.                 set begin [lindex $ll 0]
  692.                 set end [lindex $ll 1]
  693.                 
  694.                 set beginline [getText $begin [nextLineStart  $begin]]
  695.                 if { [string first "$begComment" "$beginline" ] != $p } {
  696.                     message "First line failed"
  697.                     return 1
  698.                 }
  699.                 
  700.                 set endline [getText $end [nextLineStart $end]]
  701.                 set epos [string last "$endComment" "$endline"]
  702.                 incr epos [string length $endComment]
  703.                 set s [string range $endline $epos end ]
  704.                 set s [string trimright $s]
  705.                 
  706.                 if { $s != "" } {
  707.                     message "Last line failed"
  708.                     return 1
  709.                 }
  710.                 #goto $end
  711.                 set end [nextLineStart $end]
  712.                 select $begin $end
  713.             }
  714.         }
  715.     } else {
  716.         # commenting out
  717.         set searchString {^[ \t]*$}
  718.         set searchResult1 [search -s -f 0 -r 1 -n $searchString $pos]
  719.         set searchResult2 [search -s -f 1 -r 1 -n $searchString $pos]
  720.         if {[llength $searchResult1]} then {
  721.             set posStart [expr [lindex $searchResult1 1] +1]
  722.         } else {
  723.             set posStart 0
  724.         }
  725.         if {[llength $searchResult2]} then {
  726.             set posEnd [lindex $searchResult2 0]
  727.         } else {
  728.             set posEnd [expr [maxPos] +1]
  729.             goto [maxPos]
  730.             insertText "\n"
  731.         }
  732.         select $posStart $posEnd
  733.     }
  734.     
  735.      set str "Do you wish to "
  736.      if $uncomment { append str "uncomment" } else { append str "comment out" }
  737.      append str " this region?"
  738.     if { [askyesno $str] == "yes" } {
  739.         return 0
  740.     } else {
  741.         return 1
  742.     }
  743. }
  744.  
  745.  
  746. proc prevLineStart { pos } {
  747.     return [lineStart [expr [lineStart $pos]-1]]
  748. }
  749.  
  750. proc commentSameStart { line start } {
  751.     regsub -all {    } "$line" " " line
  752.     if { [string first "$start" "$line"] == 0 } {
  753.         return 1
  754.     } else {
  755.         return 0
  756.     }
  757. }
  758.  
  759. proc commentGetFillLines { start } {
  760.     set pos [getPos]
  761.     regsub -all {[\t]} $start " " start
  762.     set line "$start"
  763.     
  764.     set p $pos
  765.     while { [commentSameStart "$line" "$start"] } {
  766.         set p [nextLineStart $p]
  767.         set line [getText [lineStart $p] [nextLineStart $p]]
  768.     }
  769.     set end [lineStart $p]
  770.     
  771.     set p $pos
  772.     set line "$start"
  773.     while { [commentSameStart "$line" "$start"] } {
  774.         set p [prevLineStart $p]
  775.         set line [getText [prevLineStart $p] [lineStart $p] ]
  776.     }
  777.     set begin [prevLineStart $p]
  778.     return [list $begin $end]
  779. }
  780.  
  781. ## 
  782.  # Author: Vince Darley    <mailto:vince@das.harvard.edu> 
  783.  ##
  784.  
  785. proc commentParagraph {} {
  786.  
  787. # Preliminaries
  788.     if [commentGetRegion Paragraph] { return }
  789.     
  790.     set commentList [commentCharacters Paragraph]
  791.     if { [llength $commentList] == 0 } { return }
  792.     
  793.     set begComment [lindex $commentList 0]
  794.     set endComment [lindex $commentList 1]
  795.     set fillChar [lindex $commentList 2]
  796.     
  797.  
  798. # First make sure we grab a full block of lines and adjust highlight
  799.  
  800.     set start [getPos]
  801.     set start [lineStart $start]
  802.     set end [selEnd]
  803.     set end [nextLineStart [expr $end-1]]
  804.     select $start $end
  805.  
  806. # Now get rid of any tabs
  807.     
  808.     if { $end < [maxPos] } then {
  809.         createTMark stopComment [expr $end+1]
  810.         tabsToSpaces
  811.         gotoTMark stopComment
  812.         set end [expr [getPos]-1]
  813.         removeTMark stopComment
  814.     } else {
  815.         tabsToSpaces
  816.         set end [maxPos]
  817.     }
  818.     select $start $end
  819.     set text [getText $start $end]
  820.     
  821. # Next turn it into a list of lines--possibly drop an empty 'last line'
  822.  
  823.     set lineList [split $text "\r"]
  824.     set ll [llength $lineList]
  825.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  826.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  827.     }
  828.     set numLines [llength $lineList]
  829.  
  830. # Find left margin for these lines
  831.     set lmargin 100
  832.     for { set i 0 } { $i < $numLines } { incr i } {
  833.         set l [lindex $lineList $i]
  834.         set lm [expr [string length $l] - [string length [string trimleft $l]]]
  835.         if { $lm < $lmargin } { set lmargin $lm }
  836.     }
  837.     set ltext ""
  838.     for { set i 0 } { $i < $lmargin } { incr i } {
  839.         append ltext " "
  840.     }
  841.     
  842. # For each line add stuff on left and concatenate everything into 'text'. 
  843.  
  844.     set text ${ltext}${begComment}\r
  845.     
  846.     for { set i 0 } { $i < $numLines } { incr i } {
  847.         append text ${ltext}${fillChar}[string range [lindex $lineList $i ] $lmargin end]\r
  848.     }
  849.     append text ${ltext}${endComment}\r
  850.     
  851. # Now replace the old stuff, turn spaces to tabs, and highlight
  852.  
  853.     replaceText    $start $end    $text
  854.     set    end    [expr {$start+[string length $text]}]
  855.     cleverSpacesToTabs $start $end
  856. }
  857.  
  858. ## 
  859.  # Author: Vince Darley    <mailto:vince@das.harvard.edu> 
  860.  ##
  861.  
  862. proc uncommentParagraph {} {
  863.  
  864. # Preliminaries
  865.     if [commentGetRegion Paragraph 1] { return }
  866.     
  867.     set commentList [commentCharacters Paragraph]
  868.     if { [llength $commentList] == 0 } { return }
  869.     
  870.     set begComment [lindex $commentList 0]
  871.     set endComment [lindex $commentList 1]
  872.     set fillChar [lindex $commentList 2]
  873.  
  874.     set aSpace " "
  875.     set aTab \t
  876.  
  877. # First make sure we grab a full block of lines and adjust highlight
  878.  
  879.     set start [getPos]
  880.     set start [lineStart $start]
  881.     set end [selEnd]
  882.     set end [nextLineStart [expr $end-1]]
  883.     select $start $end
  884.     set text [getText $start $end]
  885.  
  886. # Find left margin for these lines
  887.     set l [string range $text 0 [string first "\r" $text] ]
  888.     set lmargin [expr [string length $l] - [string length [string trimleft $l]]]
  889.  
  890. # Make sure we're at the start and end of the paragraph
  891.  
  892.     set startOK [string first $begComment $text]
  893.     set endOK [string last $endComment $text]
  894.     set textLength [string length $text]
  895.     if { $startOK != $lmargin || ($endOK != [expr {$textLength-[string length $endComment]-1}] || $endOK == -1) } then {
  896.         alertnote "You must highlight the entire comment paragraph, including the tail ends."
  897.         return
  898.     }
  899.  
  900. # Now get rid of any tabs
  901.     
  902.     if { $end < [maxPos] } then {
  903.         createTMark stopComment [expr $end+1]
  904.         tabsToSpaces
  905.         gotoTMark stopComment
  906.         set end [expr [getPos]-1]
  907.         removeTMark stopComment
  908.     } else {
  909.         tabsToSpaces
  910.         set end [maxPos]
  911.     }
  912.     select $start $end
  913.     set text [getText $start $end]
  914.     
  915. # Next turn it into a list of lines--possibly drop an empty 'last line'
  916.  
  917.     set lineList [split $text "\r"]
  918.     set ll [llength $lineList]
  919.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  920.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  921.     }
  922.     set numLines [llength $lineList]
  923.     
  924. # Delete the first and last lines, recompute number of lines
  925.  
  926.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  927.     set lineList [lreplace $lineList 0 0 ]
  928.     set numLines [llength $lineList]
  929.  
  930. # get the left margin
  931.     set lmargin [string first $fillChar [lindex $lineList 0]]
  932.     set ltext ""
  933.     for { set i 0 } { $i < $lmargin } { incr i } {
  934.         append ltext " "
  935.     }
  936.  
  937. # For each line trim stuff on left and spaces and stuff on right and splice
  938.     set eliminate $fillChar$aSpace$aTab
  939.     set dropFromLeft [expr [string length $fillChar] + $lmargin]
  940.     set text ""
  941.     for { set i 0 } { $i < $numLines } { incr i } {
  942.         set thisLine [lindex $lineList $i]
  943.         set thisLine [string trimright $thisLine $eliminate]
  944.         set thisLine ${ltext}[string range $thisLine $dropFromLeft end]
  945.         set text $text$thisLine\r
  946.     }
  947.     
  948. # Now replace the old stuff, turn spaces to tabs, and highlight
  949.  
  950.  
  951.     replaceText    $start $end    $text
  952.     set    end    [expr {$start+[string length $text]}]
  953.     cleverSpacesToTabs $start $end
  954. }
  955.  
  956.  
  957. proc cleverTabsToSpaces { start end } {
  958.     cleverSpacesTabs tabsToSpaces $start $end
  959. }
  960.  
  961. proc cleverSpacesToTabs { start end } {
  962.     cleverSpacesTabs spacesToTabs $start $end
  963. }
  964.  
  965. proc cleverSpacesTabs { fn start end } {
  966.    set e [expr $end+1]
  967.    if { $e > [maxPos] } { 
  968.        goto $end
  969.        openLine
  970.    }
  971.    createTMark stopComment $e
  972.    select $start $end
  973.    $fn
  974.    gotoTMark stopComment
  975.    set end [expr [getPos]-1]
  976.    removeTMark stopComment
  977.    return [list $start $end]
  978. }
  979.  
  980. #===============================================================================
  981.  
  982. proc stripNameCount str {
  983.     regsub { <\d+>} $str {} str
  984.     return $str
  985. }
  986.  
  987. #===============================================================================
  988.  
  989. # Used to create a popup of all funcs in window. Routine 
  990. # should return list containing, consecutively, proc name and
  991. # start of definition. 
  992. proc parseFuncsAlpha {} {
  993.     global mode sortFuncsMenu
  994.     
  995.     if {[info procs "parseFuncs$mode"] != ""} {
  996.         return [parseFuncs$mode]
  997.     } else {
  998.         global funcExpr parseExpr
  999.         
  1000.         set pos 0
  1001.         if $sortFuncsMenu {
  1002.             while {[set res [search -s -f 1 -r 1 -i 0 -n $funcExpr $pos]] != ""} {
  1003.                 if {[regexp $parseExpr [getText [car $res] [cadr $res]] dummy word]} {
  1004.                     lappend m [list $word [car $res]]
  1005.                 }
  1006.                 set pos [cadr $res]
  1007.             }
  1008.             regsub -all "\[\{\}\]" [lsort -ignore $m] "" m
  1009.         } else {
  1010.             while {[set res [search -s -f 1 -r 1 -i 0 -n $funcExpr $pos]] != ""} {
  1011.                 if {[regexp $parseExpr [getText [car $res] [cadr $res]] dummy word]} {
  1012.                     lappend m $word [car $res]
  1013.                 }
  1014.                 set pos [cadr $res]
  1015.             }
  1016.         }
  1017.         return $m
  1018.     }
  1019. }
  1020.